home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / mosmllib / Strbase.sml < prev    next >
Encoding:
Text File  |  1997-08-18  |  12.6 KB  |  308 lines  |  [TEXT/Moml]
  1. (* Strbase -- internal utilities for String and Substring *)
  2.  
  3. val maxlen = 16777211;                  (* = (2^22-1)*4-1, with 32 bit *)
  4.  
  5. local 
  6.     prim_val sub_      : string -> int -> char         = 2 "get_nth_char";
  7.     prim_val mkstring_ : int -> string                 = 1 "create_string";
  8.     prim_val blit_     : string -> int -> string -> int -> int -> unit 
  9.                                                        = 5 "blit_string";
  10.     prim_val set_nth_  : string -> int -> char -> unit = 3 "set_nth_char";
  11.  
  12.     fun str c = 
  13.         let val newstr = mkstring_ 1
  14.         in set_nth_ newstr 0 c; newstr end;
  15.  
  16.     fun revconcat strs =
  17.         let fun acc [] len       = len
  18.               | acc (v1::vr) len = acc vr (size v1 + len)
  19.             val len = acc strs 0
  20.             val newstr = if len > maxlen then raise Size else mkstring_ len 
  21.             fun copyall to []       = () (* Now: to = 0. *)
  22.               | copyall to (v1::vr) = 
  23.                 let val len1 = size v1
  24.                     val to   = to - len1
  25.                 in blit_ v1 0 newstr to len1; copyall to vr end
  26.         in copyall len strs; newstr end;
  27.  
  28.     fun rest (ss as (s, i, n)) = 
  29.         if n = 0 then ss else (s, i+1, n-1);
  30.  
  31. in
  32.  
  33.  
  34. fun foldl f e (s,i,n) = 
  35.     let val stop = i+n
  36.         fun h j res = if j>=stop then res 
  37.                       else h (j+1) (f (sub_ s j, res))
  38.     in h i e end;
  39.  
  40. fun translate f (s,i,n) = 
  41.     let val stop = i+n
  42.         fun h j res = if j>=stop then res 
  43.                       else h (j+1) (f(sub_ s j) :: res)
  44.     in revconcat(h i []) end;
  45.  
  46. local
  47.     fun scanl chop pred (s, i, n) = 
  48.         let
  49.             val stop = i+n
  50.             fun scan j = if j < stop andalso pred(sub_ s j) then scan (j+1)
  51.                          else j
  52.         in
  53.             chop (s, i, n, scan i - i)
  54.         end
  55.     fun scanr chop pred (s, i, n) = 
  56.         let
  57.             val stop = i-1
  58.             fun scan j = if j > stop andalso pred(sub_ s j) then scan(j-1)
  59.                          else j
  60.         in
  61.             chop (s, i, n, scan (i+n-1) - i + 1)
  62.         end
  63. in
  64.     fun splitl p = scanl (fn (s, i, n, k) => ((s, i, k), (s, i+k, n-k))) p
  65.     fun splitr p = scanr (fn (s, i, n, k) => ((s, i, k), (s, i+k, n-k))) p
  66.     fun dropl  p = scanl (fn (s, i, n, k) => (s, i+k, n-k))              p
  67.     fun dropr  p = scanr (fn (s, i, n, k) => (s, i, k))                  p
  68.     fun takel  p = scanl (fn (s, i, n, k) => (s, i, k))                  p
  69.     fun taker  p = scanr (fn (s, i, n, k) => (s, i+k, n-k))              p
  70. end (* local *)
  71.  
  72. fun tokens isDelim ss = 
  73.     let fun findTok ss = dropl isDelim ss
  74.         fun h (remains as (_, _, n)) res = 
  75.             if n = 0 then List.rev res
  76.             else
  77.                 let val (token, aftertoken) = 
  78.                     splitl (fn c => not(isDelim c)) remains 
  79.                 in h (findTok aftertoken) (token :: res) end
  80.     in h (findTok ss) [] end;
  81.  
  82. fun fields isDelim ss = 
  83.     let fun h ss res = 
  84.             let val (field, afterfield as (_, _, n)) = 
  85.                 splitl (fn c => not(isDelim c)) ss
  86.             in 
  87.                 if n = 0 then List.rev (field :: res)
  88.                 else h (rest afterfield) (field :: res) 
  89.             end
  90.     in h ss [] end;
  91.  
  92. local
  93.     (* Conversion to and from ML and C character escape sequences *)
  94.   
  95.     exception BadEscape
  96.     prim_val ord_ : char -> int = 1 "identity";
  97.     prim_val chr_ : int -> char = 1 "identity";
  98.     val maxOrd = 255                    (* Must equal Char.maxOrd *)
  99.     fun chr i = if i<0 orelse i>maxOrd then raise BadEscape else chr_ i;
  100.             
  101.  
  102.     (* Below, 48 = Char.ord #"0" and 55 = Char.ord #"A" - 10. *)
  103.     fun decval c = ord_ c - 48;
  104.     fun digit n = chr_(48 + n);
  105.     fun hexval c = 
  106.         if #"0" <= c andalso c <= #"9" then ord_ c - 48
  107.         else (ord_ c - 55) mod 32;
  108.     fun isOctDigit c = #"0" <= c andalso c <= #"7"
  109.     fun isHexDigit c = #"0" <= c andalso c <= #"9" 
  110.                        orelse #"a" <= c andalso c <= #"f"
  111.                        orelse #"A" <= c andalso c <= #"F"
  112.  
  113. in
  114. fun fromMLescape getc source = 
  115.     let fun decimal cont src code =
  116.         case getc src of
  117.             NONE          => raise BadEscape
  118.           | SOME(c, rest) => if #"0" <= c andalso c <= #"9" 
  119.                              then cont rest (code * 10 + ord_ c - 48)
  120.                              else raise BadEscape
  121.         val from3Dec = 
  122.             decimal (decimal (decimal (fn src => fn code => (chr code, src))))
  123.         fun skipform src = 
  124.             case getc src of
  125.                 NONE              => NONE
  126.               | SOME(#"\\", src1) => 
  127.                     (case getc src1 of
  128.                          NONE              => NONE
  129.                        | SOME(#"\\", src2) => fromMLescape getc src2
  130.                        | res               => res)
  131.               | SOME(c, rest)     => 
  132.                     if c = #" " orelse #"\009" <= c andalso c <= #"\013" then
  133.                         skipform rest 
  134.                     else NONE
  135.     in
  136.         case getc source of
  137.             NONE              => NONE
  138.           | SOME(#"a", rest)  => SOME(#"\007", rest) (* BEL *)
  139.           | SOME(#"b", rest)  => SOME(#"\008", rest) (* BS  *)
  140.           | SOME(#"t", rest)  => SOME(#"\009", rest) (* HT  *)
  141.           | SOME(#"r", rest)  => SOME(#"\010", rest) (* LF  *)
  142.           | SOME(#"n", rest)  => SOME(#"\013", rest) (* CR  *)
  143.           | SOME(#"v", rest)  => SOME(#"\011", rest) (* VT  *)
  144.           | SOME(#"f", rest)  => SOME(#"\012", rest) (* FF  *)
  145.           | SOME(#"\"", rest) => SOME(#"\"", rest)
  146.           | SOME(#"\\", rest) => SOME(#"\\", rest)
  147.           | SOME(#" ", rest)  => skipform rest
  148.           | SOME(#"\n", rest) => skipform rest
  149.           | SOME(#"\t", rest) => skipform rest
  150.           | SOME(#"^", rest)  => 
  151.                 (case getc rest of
  152.                      NONE => NONE
  153.                    | SOME(c, rest) => 
  154.                          if #"@" <= c andalso c <= #"_" then
  155.                              SOME(chr_ (ord_ c - 64), rest)
  156.                          else
  157.                              NONE)
  158.           | _     => SOME (from3Dec source 0) 
  159.                      handle BadEscape => NONE
  160.     end
  161.  
  162.     fun toMLescape c =
  163.         case c of 
  164.             #"\\"   => "\\\\"
  165.           | #"\""   => "\\\""
  166.           | _       => 
  167.             if #"\032" <= c then
  168.                 if c <= #"\126" then str c
  169.                 else let val n = ord_ c 
  170.                          val newstr = mkstring_ 4
  171.                      in 
  172.                          set_nth_ newstr 0 #"\\";
  173.                          set_nth_ newstr 1 (digit(n div 100));
  174.                          set_nth_ newstr 2 (digit(n div 10 mod 10));
  175.                          set_nth_ newstr 3 (digit(n mod 10));
  176.                          newstr 
  177.                      end
  178.             else
  179.                 (case c of
  180.                      #"\007" => "\\a"                   (* BEL,  7 *)
  181.                    | #"\008" => "\\b"                   (* BS,   8 *)
  182.                    | #"\009" => "\\t"                   (* HT,   9 *)
  183.                    | #"\010" => "\\r"                   (* LF,  10 *)
  184.                    | #"\013" => "\\n"                   (* CR,  13 *)
  185.                    | #"\011" => "\\v"                   (* VT,  11 *)
  186.                    | #"\012" => "\\f"                   (* FF,  12 *)
  187.                    | _       => let val n = ord_ c 
  188.                                     val newstr = mkstring_ 3
  189.                                 in 
  190.                                     set_nth_ newstr 0 #"\\";
  191.                                     set_nth_ newstr 1 #"^";
  192.                                     set_nth_ newstr 2 (chr_ (ord_ c + 64));
  193.                                     newstr 
  194.                                 end)
  195.  
  196. (* C character escape functions, 1995-10-30 *)
  197. (* C character escape codes according to Kernighan & Ritchie: The C  *
  198.  * Programming Language, second edition, page 193                    *)
  199.  
  200.     fun toCescape c =
  201.         case c of 
  202.             #"\\"   => "\\\\"
  203.           | #"?"    => "\\?"
  204.           | #"'"    => "\\'"
  205.           | #"\""   => "\\\""
  206.           | _       => 
  207.             if #"\032" <= c andalso c <= #"\126" then str c
  208.             else 
  209.                 (case c of 
  210.                      #"\010" => "\\r"                   (* LF,  10 *)
  211.                    | #"\013" => "\\n"                   (* CR,  13 *)
  212.                    | #"\009" => "\\t"                   (* HT,   9 *)
  213.                    | #"\011" => "\\v"                   (* VT,  11 *)
  214.                    | #"\008" => "\\b"                   (* BS,   8 *)
  215.                    | #"\012" => "\\f"                   (* FF,  12 *)
  216.                    | #"\007" => "\\a"                   (* BEL,  7 *)
  217.                    | _       => let val n = ord_ c 
  218.                                     val newstr = mkstring_ 4
  219.                                 in 
  220.                                     set_nth_ newstr 0 #"\\";
  221.                                     set_nth_ newstr 1 (digit(n div 64));
  222.                                     set_nth_ newstr 2 (digit(n div 8 mod 8));
  223.                                     set_nth_ newstr 3 (digit(n mod 8));
  224.                                     newstr 
  225.                                 end);
  226.  
  227.     fun fromCescape' getc src =         (* raises BadEscape *)
  228.         let fun fromHex src code =
  229.                 case getc src of
  230.                     NONE          => (chr code, src)
  231.                   | SOME(c, rest) => if isHexDigit c 
  232.                                      then fromHex rest (code * 16 + hexval c)
  233.                                      else (chr code, src)
  234.             fun octalOpt cont src code =
  235.                 case getc src of
  236.                     NONE          => (chr code, src)
  237.                   | SOME(c, rest) => 
  238.                         if #"0" <= c andalso c <= #"7"
  239.                         then cont rest (code * 8 + ord_ c - 48)
  240.                         else (chr code, src)
  241.             val fromOct = 
  242.                 octalOpt (octalOpt (fn src => fn code => (chr code, src)))
  243.         in
  244.             case getc src of
  245.                  NONE              => raise BadEscape
  246.                | SOME(#"r",  src1) => (#"\010", src1)
  247.                | SOME(#"n",  src1) => (#"\013", src1)
  248.                | SOME(#"t",  src1) => (#"\009", src1) 
  249.                | SOME(#"v",  src1) => (#"\011", src1)
  250.                | SOME(#"b",  src1) => (#"\008", src1)
  251.                | SOME(#"f",  src1) => (#"\012", src1)
  252.                | SOME(#"a",  src1) => (#"\007", src1)
  253.                | SOME(#"\\", src1) => (#"\\",   src1)
  254.                | SOME(#"?",  src1) => (#"?",    src1)
  255.                | SOME(#"'",  src1) => (#"'",    src1)
  256.                | SOME(#"\"", src1) => (#"\"",   src1)
  257.                | SOME(#"x",  src1) => 
  258.                      (case getc src1 of 
  259.                           NONE          => raise BadEscape
  260.                         | SOME(c, src2) => 
  261.                               if isHexDigit c then fromHex src2 (hexval c)
  262.                               else raise BadEscape)
  263.                | SOME(c,     src1) => 
  264.                           if isOctDigit c then fromOct src1 (decval c)
  265.                           else raise BadEscape
  266.         end
  267.                  
  268.     fun fromCescape getc src =          (* Returns a char option *)
  269.         SOME (fromCescape' getc src) 
  270.         handle 
  271.            BadEscape => NONE (* Illegal C escape sequence or character code *)
  272.          | Overflow  => NONE (* Character code far too large                *)
  273.             
  274.     fun fromCString s =
  275.         let fun getc i = if i < size s then SOME (sub_ s i, i+1) else NONE
  276.             val max = ref 1
  277.             val tmp = ref (mkstring_ (!max))
  278.             fun realloc () =
  279.                 let val newmax = 2 * !max
  280.                     val newtmp = mkstring_ newmax
  281.                 in 
  282.                     blit_ (!tmp) 0 newtmp 0 (!max);
  283.                     max := newmax;
  284.                     tmp := newtmp
  285.                 end
  286.             fun sub_string_ s start len =
  287.                 let val res = mkstring_ len
  288.                 in blit_ s start res 0 len; res end;
  289.             fun h len src =
  290.                 let fun addchar c = (if len >= !max then realloc () else ();
  291.                                      set_nth_ (!tmp) len c)
  292.                 in
  293.                     case getc src of
  294.                         NONE              => sub_string_ (!tmp) 0 len
  295.                       | SOME(#"\\", src1) => 
  296.                             let val (c, src2) = fromCescape' getc src1
  297.                             in addchar c; h (len+1) src2 end 
  298.                       | SOME(c,     src1) => (addchar c; h (len+1) src1)
  299.                 end
  300.         in 
  301.             SOME (h 0 0) 
  302.          handle 
  303.            BadEscape => NONE (* Illegal C escape sequence or character code *)
  304.          | Overflow  => NONE (* Character code far too large                *)
  305.         end
  306. end (* local *)
  307. end (* local *)
  308.